home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / seditMime.tcl.z / seditMime.tcl
Text File  |  2002-07-08  |  28KB  |  964 lines
  1. # seditMime.tcl
  2. #
  3. # Support for composing MIME-compliant messages in sedit
  4. #
  5. # The basic strategy for composing multipart messages is to maintain a set
  6. # of marks in the text that delimit the various parts and their headers.
  7. # In addition, a tag giving the type covers a given part.  The mark names
  8. # are kept in  sedit($t,marks)
  9. #
  10. # Copyright (c) 1993 Xerox Corporation.
  11. # Use and copying of this software and preparation of derivative works based
  12. # upon this software are permitted. Any distribution of this software or
  13. # derivative works must comply with all applicable United States export
  14. # control laws. This software is made available AS IS, and Xerox Corporation
  15. # makes no warranty about the software, its performance or its conformity to
  16. # any specification.
  17.  
  18. proc SeditMimeReset { t } {
  19.     global sedit
  20.     Exmh_Debug SeditMimeReset
  21.     set sedit($t,multi) 0    ;# Not yet a multipart message
  22.     set sedit($t,mime) 0    ;# No MIME type yet
  23.     set sedit($t,dash) 0    ;# 1 if ---- header separator
  24.     foreach item [array names sedit] {
  25.     if [regexp "^$t,boundary" $item] {
  26.         unset sedit($item)
  27.     }
  28.     }
  29.     foreach tag [$t tag names] {
  30.     catch {$t tag delete $tag}
  31.     }
  32.     foreach mark [$t mark names] {
  33.     catch {$t mark unset $mark}
  34.     }
  35. }
  36. proc SeditMimeParse { t } {
  37.  
  38.     # This attempts to rebuild the mark and tag structure from a draft.
  39.     # It does not build up everything, just the
  40.     # type=<type> tags for leaf parts (not multi's)
  41.     # part=<index> tags
  42.     # multi<level>.next for appending parts.
  43.     # Charset for fixing character sets
  44.  
  45.     global sedit
  46.     Exmh_Debug SeditMimeParse $t
  47.     set state header
  48.     set type text/plain
  49.     set level {}
  50.     set part 0
  51.     set boundaries {}
  52.     set key {}        ;# current header key
  53.     set content-type {}    ;# Content-Type line
  54.     for {set i 1} {[$t compare $i.0 < end]} {incr i} {
  55.     set line [$t get $i.0 $i.end]
  56.     set len [string length $line]
  57.     if {$state == "header"} {
  58.         if {[regexp {^[     ]+} $line]} {
  59.         if [regexp -nocase content-type $key] {
  60.             append content-type $line
  61.         }
  62.         } elseif {[regexp -nocase {^([^:]+):(.*)$} $line match key value]} {
  63.         if [regexp -nocase content-type $key] {
  64.             $t mark set beginpart $i.0
  65.             set sedit($t,mime) 1
  66.             set sedit($t,part) 0
  67.             set content-type $value
  68.         }
  69.         } elseif {$len == 0 || [regexp ^-- $line]} {
  70.         set state body
  71.         # Decode content-type
  72.         if {[string length ${content-type}] != 0} {
  73.             set params [split ${content-type} \;]
  74.             Exmh_Debug SeditMimeParse MIME $params
  75.             set type [string tolower [string trim [lindex $params 0]]]
  76.             if {[string match multipart/* $type]} {
  77.             set sedit($t,multi) 1
  78.             set sedit($t,level,0) 0
  79.             if {[string length $level] == 0} {
  80.                 set level 0
  81.             } else {
  82.                 global sedit
  83.                 incr sedit($t,level,$level)
  84.                 set level ${level}.$sedit($t,level,$level)
  85.                 set sedit($t,level,$level) 0
  86.             }
  87.             $t mark set level=$level $i.0
  88.             $t mark set multi${level}.next end
  89.             }
  90.             if {[string match text/* $type]} {
  91.             $t tag add Charset beginpart "beginpart lineend"
  92.             }
  93.             foreach sub [lrange $params 1 end] {
  94.             if [regexp {([^=]+)=(.+)} $sub match key val] {
  95.                 set key [string trim [string tolower $key]]
  96.                 set val [string trim $val \ \"]
  97.                 if {[string compare $key boundary] == 0} {
  98.                 # push new boundary onto the stack
  99.                 set sedit($t,boundary,$level) $val
  100.                 set boundaries [linsert $boundaries 0 $val]
  101.                 }
  102.             }
  103.             }
  104.         }
  105.         }
  106.     } else {
  107.         if [regexp "\[\x80-\xff\]" $line] {
  108.         set sedit($t,8bit) 1
  109.         }
  110.         foreach b $boundaries {
  111.         if [regexp ^--$b\(--\)?\$ $line match alldone] {
  112.             if {![string match multipart/* $type]} {
  113.             $t tag add type=$type beginpart $i.0
  114.             $t tag add part=$part beginpart $i.0
  115.             }
  116.             set type text/plain
  117.             incr part
  118.             if {[string compare $alldone --] == 0} {
  119.             $t tag add level=${level} level=${level} $i.0
  120.             $t mark set multi${level}.next $i.0
  121.             set level [file root $level]
  122.             set boundaries [lrange $boundaries 1 end]
  123.             set done 1
  124.             } else {
  125.             set state header
  126.             set done 0
  127.             }
  128.             break
  129.         }
  130.         }
  131.     }
  132.     }
  133.     if {$sedit($t,mime)} {
  134.     $t tag delete Body
  135.     if {!$sedit($t,multi)} {
  136.         $t tag add part=0 beginpart end
  137.         $t tag add type=$type beginpart end
  138.         $t tag add level= beginpart end
  139.         $t mark set headerOrig beginpart
  140.         $t mark unset beginpart
  141.     }
  142.     }
  143. }
  144.  
  145. proc SeditMimeType { type {promote {}} } {
  146.     # 
  147.     # Called from the user menu to define or add a type to a message.
  148.     # This returns a text mark at which to insert the body.
  149.     #
  150.     global sedit
  151.     set t $sedit(t)                ;# active text widget
  152.     set promote [string length $promote]    ;# Promote existing body
  153.  
  154.     Exmh_Debug SeditMimeType $type promote=$promote
  155.  
  156.     if {! $sedit($t,mime)} {
  157.     #
  158.     # No type information yet.
  159.     #
  160.     if {$promote} {
  161.         set keep 1        ;# Keep existing body
  162.     } else {
  163.         SeditBodyDialog $t $type
  164.         set keep $sedit($t,body)
  165.     }
  166.     return [SeditMimeFirstPart $t $type $promote $keep]
  167.     } elseif {! $sedit($t,multi) && !$promote} {
  168.     #
  169.     # Adding another part and not yet multipart structured
  170.     #
  171.     $t mark set header headerOrig
  172.     if {![string match multipart/* $type]} {
  173.         SeditStartMulti $t multipart/mixed
  174.         return [SeditBoundary&Type $t $type 0]
  175.     } else {
  176.         return [SeditStartMulti $t $type]
  177.     }
  178.     } else {
  179.     #
  180.     # Figure out where we are and ask the user what to do.
  181.     #
  182.     set oldtype {}
  183.     set level {}
  184.     set part {}
  185.     if {[$t compare insert <= header]} {
  186.         set spot [$t index "header + 1 line"]
  187.     } else {
  188.         set spot [$t index insert]
  189.     }
  190.     foreach tag [$t tag names $spot] {
  191.         regexp {level=(.+)} $tag match level
  192.         regexp {type=(.+)} $tag match oldtype
  193.         regexp {part=(.+)} $tag match part
  194.     }
  195.     if {$promote && [string match {text/*} $type]} {
  196.         if {$part == ""} {
  197.         # lost part headers? 
  198.         set sedit($t,newpart) 1
  199.         } else {
  200.         # change existing part
  201.         set sedit($t,newpart) 0
  202.         }
  203.     } else {
  204.         SeditPartDialog $t $oldtype $type $level $part
  205.     }
  206.     if {$sedit($t,newpart) < 0} {
  207.         # Abort
  208.         return
  209.     }
  210.     set promote [expr $sedit($t,newpart) == 0]
  211.     return [SeditMimePart $t $type $promote $oldtype $part $level]
  212.     }
  213. }
  214. proc SeditMimeFirstPart { t type promote keep} {
  215.     global sedit
  216.     set sedit($t,part) 0        ;# Part index
  217.     set sedit($t,mime) 1        ;# Have Mime header
  218.     #
  219.     # Initial type specification from untyped body
  220.     # header mark is at the end of the last header line.
  221.     # Upon return, headerOrig is set to the beginning of the first
  222.     # new header line inserted.  This is used later when promoting
  223.     # a simple typed body to a multipart structure.
  224.     #
  225.     if {!$keep} {
  226.     # Delete body, if any - tag range may return null
  227.     catch {eval {$t delete} [$t tag range Body]}
  228.     }
  229.     $t tag delete Body
  230.  
  231.     Exmh_Debug SeditMimeFirstPart $type
  232.  
  233.     # Position the header mark at the begining of the line where
  234.     # we will be inserting new headers (Content-Type, etc.)
  235.     if [catch {$t index header}] {
  236.     SeditMsg $t "No message?"
  237.     $t mark set header end
  238.     }
  239.     if [$t compare header == "header linestart"] {
  240.     # last header line was deleted during editing -- back up
  241.     # over newline
  242.     $t mark set header "header - 1c"
  243.     }
  244.     $t insert header "\nMime-Version: 1.0"
  245.     if [$t compare header == "end -1c"] {
  246.     # Nothing left after deleting the body
  247.     $t insert header "\n"
  248.     } else {
  249.     $t mark set header "header + 1c"
  250.     }
  251.     set h [$t index header]        ;# for headerOrig
  252.  
  253.     if {! $promote} {
  254.     if {! $keep} {
  255.         #
  256.         # Initialize empty part type
  257.         #
  258.         if [string match multipart/* $type] {
  259.         set mark [SeditStartMulti $t $type empty]
  260.         } else {
  261.         set mark [SeditContentType $t $type {} header]
  262.         }
  263.     } else {
  264.         #
  265.         # Initialize multipart with existing body as first part
  266.         #
  267.         set mark [SeditStartMulti $t multipart/mixed]
  268.         SeditContentType $t text/plain 0 $mark end
  269.  
  270.         if {![string match multipart/* $type]} {
  271.         #
  272.         # Now do second part (if not already multi)
  273.         #
  274.         set mark [SeditBoundary&Type $t $type 0]
  275.         }
  276.     }
  277.     } else {
  278.     #
  279.     # Promoting text/plain body
  280.     #
  281.     SeditContentType $t $type {} header end
  282.     set mark header
  283.     }
  284.     $t mark set headerOrig $h
  285.     return $mark        ;# Just after new headers
  286. }
  287. proc SeditAppendPart { type } {
  288.     global sedit
  289.     set t $sedit(t)
  290.  
  291.     Exmh_Debug SeditAppendPart $type
  292.  
  293.     if {! $sedit($t,multi)} {
  294.     #
  295.     # Adding another part and not yet multipart structured
  296.     #
  297.     $t mark set header headerOrig
  298.     if {![string match multipart/* $type]} {
  299.         SeditStartMulti $t multipart/mixed
  300.         return [SeditBoundary&Type $t $type 0]
  301.     } else {
  302.         return [SeditStartMulti $t $type]
  303.     }
  304.     }
  305.     set promote 0
  306.     set oldtype {}
  307.     set level {}
  308.     set part {}
  309.     set spot [$t index end]
  310.     foreach tag [$t tag names $spot] {
  311.     regexp {level=(.+)} $tag match level
  312.     regexp {type=(.+)} $tag match oldtype
  313.     regexp {part=(.+)} $tag match part
  314.     }
  315.     SeditMimePart $t $type $promote $oldtype $part $level
  316. }
  317. proc SeditMimePart { t type promote oldtype part level} {
  318.     #
  319.     # Add another part to the message.
  320.     # Multipart structure is already defined at this point.
  321.     #
  322.     if {$promote} {
  323.     #
  324.     # Works for text/plain -> text/enriched
  325.     #
  326.     set range [$t tag ranges part=$part]
  327.     Exmh_Debug SeditMimePart promote part=$part level=$level range=$range
  328.     $t mark set first [lindex $range 0]
  329.     $t mark set last [lindex $range 1]
  330.  
  331.     # Preserve headerOrig in case not multi yet
  332.     # Tk 4.0 tag gravity will be a blessing!
  333.     global sedit
  334.     if {! $sedit($t,multi)} {
  335.         set save [$t index headerOrig]
  336.     }
  337.     $t delete "first linestart" "first lineend + 1c"    ;# nuke old Content-Type
  338.     set mark [SeditContentType $t $type $level first last]
  339.     if [info exists save] {
  340.         $t mark set headerOrig $save
  341.     }
  342.     return $mark
  343.     } elseif {[string match multipart/* $oldtype] ||
  344.         ([string length $part] == 0)} {
  345.     # Just append the part at the current level
  346.     Exmh_Debug Appending part at level $level
  347.     return [SeditBoundary&Type $t $type $level]
  348.     } else {
  349.     set index [lindex [$t tag ranges part=$part] 1]
  350.     $t mark set addpart $index
  351.     Exmh_Debug Inserting after part $part, level $level at [$t index addpart]
  352.     return [SeditBoundary&Type $t $type $level addpart]
  353.     }
  354. }
  355. proc SeditStartMulti {t type {empty {}} } {
  356.     global sedit
  357.     set sedit($t,multi) 1
  358.     set sedit($t,level,0) 0
  359.     set sedit($t,mhn) 0            ;# Don't try MHN
  360.  
  361.     Exmh_Debug SeditStartMulti
  362.  
  363.     set h [SeditMultiInner $t $type {} header end]
  364.     $t mark set start $h
  365.  
  366.     if {$sedit($t,dash)} {
  367.     
  368.     # We need to find the dash.  Rather than assume that it has
  369.     # a particular relation to the start index, it's probably
  370.     # safer to just scan for it, since the user could either
  371.     # 1) Delete the Content-Type: header that usually precedes
  372.     # the dash or 2) Insert something else before the dash.
  373.     # Things could be bad for us if they actually deleted the dash.
  374.     set dash start
  375.     while {[$t get $dash "$dash + 1c"] != "-"} {
  376.         set dash "$dash lineend + 1c"
  377.     }
  378.  
  379.     # Insert copy of dashed line into outer body
  380.     $t insert start [$t get $dash "$dash lineend"]
  381.     # Remove dashed line from inner body, replacing it with blank line
  382.     $t delete $dash "$dash lineend"
  383.     }
  384.  
  385.     $t insert start "\nThis is a multipart MIME message.\n\n"
  386.     if {$empty == {}} {
  387.     # Wrapping up an existing part - insert boundary and tag part
  388.     set origin [$t index start]
  389.     $t insert start --[SeditBoundary $t 0]\n
  390.     Text_TagRangeOverride $t $origin start type=boundary
  391.     }
  392.     $t mark set header $h    ;# Restore header, but probably not used
  393.     return start
  394. }
  395. proc SeditMultiInner {t type level mark mark2} {
  396.     #
  397.     # Wrap up text between mark and mark2 in a multipart structure.
  398.     # Return the text index just after the new Content-Type header
  399.     #
  400.     Exmh_Debug SeditMultiInner level=$level $mark [$t index $mark] $mark2
  401.     if {[string length $level] == 0} {
  402.     set level 0
  403.     } else {
  404.     global sedit
  405.     incr sedit($t,level,$level)
  406.     set level ${level}.$sedit($t,level,$level)
  407.     set sedit($t,level,$level) 0
  408.     }
  409.     set boundary [SeditBoundary $t $level]
  410.  
  411.     set origin [$t index $mark]
  412.     $t insert $mark "Content-Type: $type ;\n\tboundary=\"$boundary\"\n"
  413.     set h [$t index $mark]
  414.     Exmh_Debug SeditMultiInner origin at $origin $mark at $h
  415.  
  416.     # Insert the terminating --boundary-- line and set multiN.next to be
  417.     # just before that --boundary-- line.
  418.  
  419.     $t insert $mark2 \n
  420.     if {[string compare $mark2 end] == 0} {
  421.     set save [$t index "end -1 line"]
  422.     } else {
  423.     set save [$t index $mark2]
  424.     }
  425.     $t insert $mark2 \n--${boundary}--\n
  426.     $t mark set multi${level}.next $save
  427.  
  428.     # Tag the text.  No part is needed.
  429.     if {[string compare $mark $mark2] == 0} {
  430.     # Empty multipart - override type tags
  431.     Text_TagRangeOverride $t $origin $mark2 type=$type
  432.     } else {
  433.     # Give type a low priority in comparison to body being wrapped up.
  434.     Text_TagRangeLow $t $origin $mark2 type=$type
  435.     }
  436.     Text_TagRangeOverride $t $origin $mark2 level=$level
  437.     return $h
  438. }
  439.  
  440. proc SeditBoundary {t level} {
  441.     global sedit
  442.     if ![info exists sedit($t,boundary,$level)] {
  443.     set sedit($t,boundary,$level) [Mime_MakeBoundary $level]
  444.     }
  445.     return $sedit($t,boundary,$level)
  446. }
  447. proc SeditBoundary&Type {t type level {mark {}} {mark2 {}} } {
  448.     global sedit
  449.     Exmh_Debug SeditBoundary&Type $type $level $mark $mark2
  450.     incr sedit($t,part)
  451.     if {[string length $level] == 0} {
  452.     set level 0
  453.     }
  454.     if {[string length $mark] == 0} {
  455.     set mark multi${level}.next
  456.     }
  457.     if [catch {$t index $mark}] {
  458.     $t mark set $mark end
  459.     }
  460.     set boundary [SeditBoundary $t $level]
  461.     scan [$t index $mark] "%d.%d" line char
  462.     if {$char != 0} {
  463.     $t insert $mark \n
  464.     }
  465.     set m [$t index $mark]
  466.     $t insert $mark "\n--$boundary\n"
  467.     Text_TagRangeOverride $t $m $mark type=boundary part=
  468.     return [SeditContentType $t $type $level $mark $mark2]
  469. }
  470. proc SeditContentType { t type level mark {mark2 {}} } {
  471.     global sedit
  472.  
  473.     Exmh_Debug SeditContentType $type mark=$mark mark2=$mark2
  474.  
  475.     if {[string length $mark2] == 0} {
  476.     set mark2 $mark
  477.     }
  478.     if [string match multipart/* $type] {
  479.     return [SeditMultiInner $t $type $level $mark $mark2]
  480.     }
  481.     if {! [regexp {(text|audio|image|message|application|video|x-.+)/} $type]} {
  482.     SeditMsg $t "Unsupported type $type"
  483.     return ""
  484.     }
  485.     set start [$t index $mark]
  486.     $t insert $mark "Content-Type: $type\n"
  487.     if {[regexp ^text $type]} {
  488.     $t tag add Charset $start "$start lineend"
  489. #    $t tag configure Charset -background red
  490.     Exmh_Debug Charset $start [$t index "$start lineend"]
  491.     }
  492.     Exmh_Debug type=$type $start $mark2
  493.     Text_TagRangeOverride $t $start $mark2 part=$sedit($t,part) type=$type level=$level
  494.     if {[string compare header $mark] == 0} {
  495.     $t mark set addpart header
  496.     $t mark set header "header -1 char"
  497.     set mark addpart
  498.     }
  499.     set save [$t index $mark]
  500.     if {$sedit(colorize) && ([winfo depth .] > 4)} {
  501.     catch {
  502.         switch -glob -- $type {
  503.         text/enriched* {
  504.             $t tag configure type=$type -background $sedit(c_enrichedBg)
  505.             $t tag configure type=$type -foreground $sedit(c_enrichedFg)
  506.         }
  507.         text/* {
  508.             $t tag configure type=$type -background $sedit(c_textBg)
  509.             $t tag configure type=$type -foreground $sedit(c_textFg)
  510.         }
  511.         audio/* {
  512.             $t tag configure type=$type -background $sedit(c_audioBg)
  513.             $t tag configure type=$type -foreground $sedit(c_audioFg)
  514.         }
  515.         image/* {
  516.             $t tag configure type=$type -background $sedit(c_imageBg)
  517.             $t tag configure type=$type -foreground $sedit(c_imageFg)
  518.         }
  519.         message/* {
  520.             $t tag configure type=$type -background $sedit(c_messageBg)
  521.             $t tag configure type=$type -foreground $sedit(c_messageFg)
  522.         }
  523.         application/* {
  524.             $t tag configure type=$type -background $sedit(c_applicationBg)
  525.             $t tag configure type=$type -foreground $sedit(c_applicationFg)
  526.         }
  527.         video/* {
  528.             $t tag configure type=$type -background $sedit(c_videoBg)
  529.             $t tag configure type=$type -foreground $sedit(c_videoFg)
  530.         }
  531.         }
  532.     }
  533.     }
  534.     Exmh_Debug SeditContentType $type returns $save
  535.     return $save    ;# end of headers mark
  536. }
  537. proc SeditFixupCharset { draft t } {
  538.     global sedit
  539.     if {$sedit($t,8bit)} {
  540.     set charset $sedit(charset)
  541.     } elseif {$sedit($t,Acharset) != {}} {
  542.         set charset $sedit($t,Acharset)   ;# set in SeditKinput_start
  543.     } else {
  544.     set charset us-ascii
  545.     }
  546.     Exmh_Debug SeditFixupCharset $charset
  547.     foreach range [FtocMakePairs [$t tag ranges Charset]] {
  548.     set start [lindex $range 0]
  549.     set end [$t index "$start lineend"]
  550.     set line [$t get $start $end]
  551.     if ![regexp -nocase charset $line] {
  552.         set line "[string trimright $line {; }]; charset=$charset"
  553.     } elseif [regexp -nocase {^(.*charset)=(.+)$} $line match first xchar] {
  554.         Exmh_Debug Existing charset $xchar
  555.         if {[regexp -nocase {(us-ascii|7bit)} $xchar] && $sedit($t,8bit)} {
  556.         set line "$first=$charset"
  557.         }
  558.     } else {
  559.         Exmh_Debug "SeditFixupCharset failed <$line>"
  560.     }
  561.     $t delete $start $end
  562.     $t insert $start $line
  563.     $t tag add Charset $start "$start lineend"
  564.     }
  565. }
  566. proc SeditPartDelete { part } {
  567.     global sedit
  568.     set t $sedit(t)
  569.     set range [$t tag range $part]
  570.     catch {$t delete [lindex $range 0] [lindex $range 1]}
  571. }
  572. proc SeditBodyDialog { t type} {
  573.     global sedit
  574.     set f [frame $t.body -bd 2 -relief ridge]
  575.     message $f.msg -aspect 1000 -text \
  576. "What should be done with the existing message body?
  577. Delete it, or preserve it as a part?"
  578.     pack $f.msg -side top -fill both
  579.     set b [frame $f.but -bd 10 -relief flat]
  580.     set sedit($t,body) 0
  581.     button $b.replace -text "Delete" -command "set sedit($t,body) 0 ; destroy $f"
  582.     button $b.save -text "Make into part" -command "set sedit($t,body) 1 ; destroy $f"
  583.     pack $b.replace $b.save -side left -padx 5
  584.     pack $b
  585.     Widget_PlaceDialog $t $f
  586.     tkwait window $f
  587.     return $sedit($t,body)
  588. }
  589. proc SeditPartDialog { t oldtype type level part } {
  590.     global sedit
  591.     set f [frame $t.part -bd 2 -relief ridge]
  592.     message $f.msg -aspect 1000 -text \
  593. "Change the type of the current part,
  594. currently $oldtype,
  595. or add a new part at level #$level,
  596. type $type,
  597. after the current part #${part}?"
  598.     pack $f.msg -side top -fill both
  599.     set b [frame $f.but -bd 10 -relief flat]
  600.     set sedit($t,newpart) 0
  601.     button $b.replace -text "Change type" -command "set sedit($t,newpart) 0 ; destroy $f"
  602.     $b.replace configure -state disabled
  603.     button $b.save -text "Add new part" -command "set sedit($t,newpart) 1 ; destroy $f"
  604.     button $b.abort -text "Cancel" -command "set sedit($t,newpart) -1 ; destroy $f"
  605.     pack $b.replace $b.save $b.abort -side left
  606.     pack $b
  607.     Widget_PlaceDialog $t $f
  608.     tkwait window $f
  609.     return $sedit($t,newpart)
  610. }
  611. proc SeditFormatMail { t out isigw } {
  612.     global sedit exmh
  613.     set tag [$t tag names]
  614.     Exmh_Debug FormatMail tags $tag
  615.     set ix [lsearch -regexp $tag text/enriched]
  616.     if {$ix >= 0} {
  617.     SeditEnrichedExpand $t
  618.     set ranges [$t tag ranges [lindex $tag $ix]]
  619.     set quote 1
  620.     set L1 [lindex $ranges 0]
  621.     set L2 [lindex $ranges 1]
  622.     set ranges [lrange $ranges 2 end]
  623.     } else {
  624.     set ranges {}
  625.     set quote 0
  626.     }
  627.     set id $sedit($t,id)
  628.     SeditCheckForIsigHeaders $t
  629.     if {$sedit($t,format) == "OnType"} {
  630.     # Prevent duplicate X-Mailer or X-Exmh-Isig-* headers
  631.     if {[catch {set end [$t index hlimit]}] &&
  632.         [catch {set end [$t index header]}]} {
  633.         set end end
  634.     }
  635.     set X1 [$t get 1.0 $end]
  636.     set X2 [$t get $end end]
  637.     regsub -all -nocase "(^|\n)(x-mailer:\[^\n\]*\n)+" $X1 {\1} X1
  638.     regsub -all -nocase "(^|\n)(x-exmh-isig-(comptype|folder):\[^\n\]*\n)+" $X1 {\1} X1
  639.     # No X-Mailer on redistributed messages
  640.     if {[string compare $exmh($id,action) dist] != 0} {
  641.         puts $out "X-Mailer: exmh $exmh(version) with $exmh(mh_vers)"
  642.     }
  643.     # Replace X-Exmh-Isig-* headers if necessary
  644.     if {$isigw} {
  645.         puts $out "X-Exmh-Isig-CompType: $sedit($t,isigc)"
  646.         puts $out "X-Exmh-Isig-Folder: $sedit($t,isigf)"
  647.     }
  648.     puts $out "$X1$X2"
  649.     return
  650.     }
  651.     # Try not to butcher non-text parts
  652.     set breakrange {}
  653.     foreach tg $tag {
  654.     if [regexp ^type=text/ $tg] {
  655.         set breakrange "$breakrange [$t tag ranges $tg]"
  656.     }
  657.     if {[string compare Body $tg] == 0} {
  658.         # no mime information
  659.         set breakrange "1.0 [$t index end]"
  660.         break
  661.     }
  662.     }
  663.     set breakrange [eval concat [SeditSortRanges $breakrange]]
  664.     Exmh_Debug FormatMail breakrange $breakrange
  665.     set F1 [lindex $breakrange 0]
  666.     set F2 [lindex $breakrange 1]
  667.     set breakrange [lrange $breakrange 2 end]
  668.     if {[string length $F1] == 0} {
  669.     set F1 -1
  670.     set break 0
  671.     } else {
  672.     set break 1
  673.     }
  674.  
  675.     set xmailer 0
  676.     set inheaders 1
  677.     scan [$t index end] "%d"  last
  678.     set plen [string length $sedit(pref,replPrefix)]
  679.  
  680.     # No X-Mailer on redistributed messages
  681.     if {[string compare $exmh($id,action) dist] != 0} {
  682.     puts $out "X-Mailer: exmh $exmh(version) with $exmh(mh_vers)"
  683.     }
  684.     # Output X-Exmh-Isig-* headers if necessary
  685.     if {$isigw} {
  686.     puts $out "X-Exmh-Isig-CompType: $sedit($t,isigc)"
  687.     puts $out "X-Exmh-Isig-Folder: $sedit($t,isigf)"
  688.     }
  689.     for {set L 1} {$L <= $last} {incr L} {
  690.     set line [$t get $L.0 $L.end]
  691.     if {$inheaders} {
  692.         # Blank or empty line terminates headers
  693.         # Leading --- terminates headers
  694.         if {[regexp {^[     ]*$} $line] || [regexp {^--+} $line]} {
  695.         set inheaders 0
  696.         }
  697.         if {[regexp -nocase {^x-mailer:} $line] ||
  698.         [regexp -nocase {^x-exmh-isig-(comptype|folder):} $line]} {
  699.         continue
  700.         }
  701.     }
  702.     if $inheaders {
  703.         set limit $sedit(lineLength)
  704.     } else {
  705.         set limit $sedit(lineLength)
  706.  
  707.         # Decide whether or not to break the body line
  708.  
  709.         if {$plen > 0} {
  710.         if {[string first $sedit(pref,replPrefix) $line] == 0} {
  711.             # This is quoted text from previous message, don't reformat
  712.             puts $out $line
  713.             if {$quote && !$inheaders} {
  714.             # Fix from <sarr@umich.edu> to handle text/enriched
  715.             if {$L > $L1 && $L < $L2 && $line != {}} {
  716.                 # enriched requires two newlines for each one.
  717.                 puts $out ""
  718.             } elseif {$L > $L2} {
  719.                 set L1 [lindex $ranges 0]
  720.                 set L2 [lindex $ranges 1]
  721.                 set ranges [lrange $ranges 2 end]
  722.                 set quote [llength $L1]
  723.             }
  724.             }
  725.             continue
  726.         }
  727.         if {$sedit($t,mhn) && [string first {#} $line] == 0} {
  728.             # This is an mhn directive
  729.             puts $out $line
  730.             continue
  731.         }
  732.         }
  733.         if {$F1 < 0} {
  734.         # Nothing left to format
  735.         puts $out $line
  736.         continue
  737.         } elseif {$L < $F1} {
  738.         # Not yet to formatted block
  739.         puts $out $line
  740.         continue
  741.         } elseif {$L > $F2} {
  742.         # Past formatted block
  743.         set F1 [lindex $breakrange 0]
  744.         set F2 [lindex $breakrange 1]
  745.         set breakrange [lrange $breakrange 2 end]
  746.         puts $out $line
  747.         if {[string length $F1] == 0} {
  748.             set F1 -1
  749.         }
  750.         continue
  751.         }
  752.     }
  753.     set climit [expr $limit-1]
  754.     set cutoff 50
  755.     set continuation 0
  756.  
  757.     while {[string length $line] > $limit} {
  758.         for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
  759.         set char [string index $line $c]
  760.         if {$char == " " || $char == "\t"} {
  761.             break
  762.         }
  763.         if {$char == ">"} {    ;# Hack for enriched formatting
  764.             break
  765.         }
  766.         }
  767.         if {$c < $cutoff} {
  768.         if {! $inheaders} {
  769.             set c [expr $limit-1]
  770.         } else {
  771.             set c [string length $line]
  772.         }
  773.         }
  774.         set newline [string range $line 0 $c]
  775.         if {! $continuation} {
  776.         puts $out $newline
  777.         } else {
  778.         puts $out \ $newline
  779.         }
  780.         incr c
  781.         set line [string trimright [string range $line $c end]]
  782.         if {$inheaders} {
  783.         set continuation 1
  784.         set limit $climit
  785.         }
  786.     }
  787.     if {$continuation} {
  788.         if {[string length $line] != 0} {
  789.         puts $out \ $line
  790.         }
  791.     } else {
  792.         puts $out $line
  793.         if {$quote && !$inheaders} {
  794.         if {$L > $L1 && $L < $L2 && $line != {}} {
  795.             # enriched requires two newlines for each one.
  796.             puts $out ""
  797.         } elseif {$L > $L2} {
  798.             set L1 [lindex $ranges 0]
  799.             set L2 [lindex $ranges 1]
  800.             set ranges [lrange $ranges 2 end]
  801.             set quote [llength $L1]
  802.         }
  803.         }
  804.     }
  805.     }
  806. }
  807. proc SeditSortRanges { ranges } {
  808.     return [lsort -command SeditRangeCompare [FtocMakePairs $ranges]]
  809. }
  810. proc SeditRangeCompare {r1 r2} {
  811.     set a [lindex $r1 0]
  812.     set b [lindex $r2 0]
  813.     return [expr {$a > $b}]
  814. }
  815.  
  816. # SeditTest1 and SeditAppendPart can be used to insert structure
  817. # without any user dialogs.
  818. proc SeditMimeDebug {} {
  819.     SeditMimeShowMarks
  820.     SeditMimeShowTags
  821. }
  822. proc SeditMimeShowMarks { {t {}} } {
  823.     global sedit
  824.     if {$t == {}} {
  825.     set t $sedit(t)
  826.     }
  827.     Exmh_Debug SeditMimeShowMarks $t
  828.     foreach mark [$t mark names] {
  829.     Exmh_Debug $mark\t[$t index $mark]
  830.     }
  831. }
  832. proc SeditMimeShowTags { {t {}} } {
  833.     global sedit
  834.     if {$t == {}} {
  835.     set t $sedit(t)
  836.     }
  837.     Exmh_Debug SeditMimeShowTags
  838.     foreach tag [$t tag names] {
  839.     Exmh_Debug [format "%-25s %s" $tag [$t tag range $tag]]
  840.     }
  841. }
  842. proc SeditTestFirst { type {keep 1} {promote 0} } {
  843.     global sedit
  844.     set t $sedit(t)
  845.     SeditMimeFirstPart $t $type $promote $keep
  846. }
  847. proc SeditTestInsert { file {newpart 1} {encoding {}} {type text/plain} {desc {}}} {
  848.     global sedit
  849.     set t $sedit(t)
  850.     SeditInsertFile {} $t $file $newpart
  851.     Sedit_FixPgpFormat [SeditId $file]
  852. }
  853. proc SeditTestInit { {charset 0} } {
  854.     global sedit
  855.     set sedit(colorize) 1
  856.     set sedit(iso) $charset
  857. }
  858. proc SeditTest1 {} {
  859.     global sedit
  860.     Msg_Compose
  861.     SeditTestInsert /tmp/part1
  862.     SeditMarkClean $sedit(t)
  863. }
  864. proc SeditTest1b {} {
  865.     global sedit
  866.     Msg_Compose
  867.     Text_MoveInsert $sedit(t) hlimit+1line
  868.     SeditTestInsert /tmp/part1
  869.     SeditMarkClean $sedit(t)
  870. }
  871. proc SeditTest2 {} {
  872.     global sedit
  873.     Msg_Compose
  874.     Text_MoveInsert $sedit(t) hlimit+1line
  875.     SeditMimeType text/enriched promote
  876.     SeditMarkClean $sedit(t)
  877. }
  878. proc SeditTest2b {} {
  879.     global sedit
  880.     SeditTest2
  881.     SeditTestInsert /tmp/sedit.patch
  882.     SeditMarkClean $sedit(t)
  883. }
  884. proc SeditTest3 {} {
  885.     global sedit
  886.     Msg_Compose
  887.     SeditMimeType audio/basic
  888.     SeditAppendPart video/basic
  889.     SeditMarkClean $sedit(t)
  890. }
  891. proc SeditTest3b {} {
  892.     global sedit
  893.     Msg_Compose
  894.     Text_MoveInsert $sedit(t) hlimit+1line
  895.     SeditMimeType audio/basic
  896.     SeditAppendPart video/basic
  897.     SeditMarkClean $sedit(t)
  898. }
  899. proc SeditTest4 {} {
  900.     global sedit
  901.     Msg_Compose
  902.     Text_MoveInsert $sedit(t) hlimit+1line
  903.     SeditTestInsert /tmp/part1
  904.     set ranges [$sedit(t) tag ranges part=1]
  905.     catch {Text_MoveInsert $sedit(t) "[lindex $ranges 0] + 1 line"}
  906.     SeditMimeType text/enriched promote
  907.     SeditMarkClean $sedit(t)
  908. }
  909. proc SeditTest4b {} {
  910.     global sedit
  911.     SeditTest4
  912.     SeditTestInsert /tmp/part2
  913.     SeditMarkClean $sedit(t)
  914. }
  915. proc SeditTest4c {} {
  916.     global sedit
  917.     SeditTest4b
  918.     SeditTestInsert /tmp/part1
  919.     SeditMarkClean $sedit(t)
  920. }
  921. proc SeditTest5 {} {
  922.     global sedit
  923.     Msg_Compose
  924.     Text_MoveInsert $sedit(t) hlimit+1line
  925.     SeditTestInsert /tmp/part1
  926.     SeditAppendPart multipart/mixed
  927.     SeditMarkClean $sedit(t)
  928. }
  929. proc SeditTest5b {} {
  930.     global sedit
  931.     SeditTest5
  932.     set ranges [$sedit(t) tag ranges level=0.1]
  933.     Text_MoveInsert $sedit(t) "[lindex $ranges 0] + 1 line"
  934.     SeditTestInsert /tmp/part2
  935.     SeditMarkClean $sedit(t)
  936. }
  937. proc SeditTest5c {} {
  938.     global sedit
  939.     SeditTest5b
  940.     Text_MoveInsert $sedit(t) "insert + 3 line"
  941.     SeditTestInsert /tmp/part1
  942.     SeditMarkClean $sedit(t)
  943. }
  944. proc SeditTest5d {} {
  945.     global sedit
  946.     SeditTest5b
  947.     Text_MoveInsert $sedit(t) "insert + 3 line"
  948.     SeditMimeType multipart/alternative
  949.     SeditMarkClean $sedit(t)
  950. }
  951. proc SeditTestFOO {} {
  952.     global sedit
  953.     Text_MoveInsert $sedit(t) hlimit+1line
  954.     SeditTestInsert /tmp/part1
  955.     SeditAppendPart multipart/mixed
  956.     set ranges [$sedit(t) tag ranges level=0.1]
  957.     Text_MoveInsert $sedit(t) "[lindex $ranges 0] + 1 line"
  958.     SeditTestInsert /tmp/part2
  959.     Text_MoveInsert $sedit(t) "insert + 3 line"
  960.     SeditTestInsert /tmp/part1
  961.     SeditMarkClean $sedit(t)
  962.  
  963. }
  964.